COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		stream functions   
C00013 ENDMK
C⊗;
;	stream functions   ;
;;
(de constream (-s) ['beta '(lambda () (nextl -s)) [['-s -s]]])

(setq next '(beta (lambda (-s) (-s)) nil))

(setq nullstReam (constream))
;;
;	VECTOR FUNCTIONS ;
;;
(DE VECTOR (-N -X ;; -R)
  (WHILE (GT -N 0) (SETQ -R (CONS -X -R) -N (SUB1 -N)))
  -R))))))

(DE SETA (-X -N -Y) (SET (NTH -N -X) -Y)))))))



;;
;	core evaluatore   ;
;;
(de aeval () (cond
  ((ATOM -EXP) (COND
    ((NUMBP -EXP) (SETQ -VAL -EXP) (RESTORE))
    ((PRIMOP -EXP) (SETQ -VAL -EXP) (RESTORE))
    ((SETQ -TEM (ASSQ -EXP -ENV)) (SETQ -VAL (CADR -TEM)) (RESTORE))
    (T (SETQ -VAL (CAR -EXP)) (RESTORE))))
  ((ATOM (CAR -EXP)) (COND
    ((EQ (CAR -EXP) QUOTE) (SETQ -VAL (CADR -EXP)) (RESTORE))
    ((SETQ -TEM (GET (CAR -EXP) 'AINT)) (SETQ -PC -TEM))
    ((EQ (CAR -EXP) 'LAMBDA) (SETQ -VAL ['BETA -EXP -ENV]) (RESTORE))
    ((SETQ -TEM (GET (CAR -EXP) 'AMACRO))
     (SETQ -EXP (APPLY -TEM -EXP)))
    (T (SETQ -EVL NIL -UNVL -EXP -PC 'AEVLIS))))
  ((EQ (CAAR -EXP) LAMBDA)
   (SETQ -EVL [(CAR -EXP)] -UNVL (CDR -EXP) -PC 'AEVLIS))
  (T (SETQ -EVL NIL -UNVL -EXP -PC 'AEVLIS)) )))))))))))))))

(DE AEVLIS () (COND
  (-UNVL (SAVEUP 'AEVLIS1) (SETQ -EXP (CAR -UNVL) -PC 'AEVAL))
  (T (SETQ -EVL (REVERSE -EVL))
     (COND
       ((ATOM (CAR -EVL)) (COND
          ((NUMBP (CAR -EVL)) (SETQ -VAL ((CAR -EVL) (CADR -EVL))) (RESTORE))
          (T (SETQ -VAL (APPLY (CAR -EVL) (CDR -EVL))) (RESTORE))))
       ((EQ (CAAR -EVL) LAMBDA)
        (SETQ -ENV (PAIRLIS (CADAR -EVL) (CDR -EVL) -ENV)
              -EXP (CDDR (CAR -EVL))
              -PC 'APROGN))
       ((EQ (CAAR -EVL) 'BETA)
        (SETQ -ENV (PAIRLIS (CADR (CADAR -EVL))
                            (CDR -EVL) (CADDR (CAR -EVL)))
              -PC 'APROGN
              -EXP (CDDR (CADAR -EVL)) ))
       ((EQ (CAAR -EVL) 'DELTA) (SETQ -CLINK (CADAR -EVL)) (RESTORE))
       (T (ERROR (PRINT 'AEVLIS))) )))))))))))))))))))))

(DE AEVLIS1 ()
  (SETQ -EVL (IF (EQ (CAR -VAL) 'MULTIPLE) (NCONC (REVERSE (CDR -VAL)) -EVL)
                 (CONS -VAL -EVL))
        -UNVL (CDR -UNVL)
        -PC 'AEVLIS)) )))))))))

(DE SAVEUP (RETAG)
  (SETQ -CLINK [-EXP -UNVL -ENV -EVL RETAG -CLINK]))

(DE RESTORE ()
  (MAPC '(-EXP -UNVL -ENV -EVL -PC -CLINK)
        '(LAMBDA (X) (SET X (NEXTL -CLINK)))))))))))))))))))

;;
;	main loop    ;

;;

(DE MLOOP ()
  (WHILE -RUN
    (SETQ -NSTEP (ADD1 -NSTEP))
    (IF -STEP (-STEP))
    (IF -LUNTIL (-UNTIL))
    (-PC)))))))

(DE RUN (-STEP)
  (SETQ -ENV NIL -PC 'AEVAL -EXP -TOP -RUN T -CLINK NIL
        -NSTEP 0 -LUNTIL ())
  (MLOOP))

        
(DE PRIMOP (-X) (MEMQ (TYPEFN -X) '(SUBR EXPR)))

(DE MULTIPLE -L (CONS 'MULTIPLE -L))

(DE PAIRLIS (-X -Y -Z)
  (IF -X (CONS [(NEXTL -X) (NEXTL -Y)] (PAIRLIS -X -Y -Z)) -Z))

(DE DEPTH (-S) ; OF CLINK'S NESTING ;
  (IF (6 -S) (ADD1 (DEPTH (6 -S))) 0))

(DE VTYPE (-EXP) (COND
  ((ATOM -EXP) -EXP)
  ((ATOM (CAR -EXP)) [(CAR -EXP) '/?-])
  ((ATOM (CAAR -EXP)) [[(CAAR -EXP) '/?-]'/?-])
  (T [['-] '/?-]))))))))))

(DE -STEP ()
  (PRINT '<-STEP-> '/# -NSTEP 'ON -PC 'WITH (VTYPE -EXP)
         'AT-DEPTH (DEPTH -CLINK))
  (STATUS 11 '/!)
  (WHILE (NEQ (SETQ -XX (READ)) T) (PPRINT (EVAL -XX)))
  (STATUS 11 '/?))

(DE -UNTIL ()
  (IF (EVAL (CONS 'OR -LUNTIL)) (-STEP))))))))

(DF UNTIL (-L) ; EX: (UNTIL (= -NSTEP 100) ;
  (SETQ -LUNTIL (CONS (CAR -L) -LUNTIL)))))))

(DE CIRC (L E) (COND
  ((ATOM L) NIL)
  ((MEMQ L E) T)
  ((CIRC (CAR L) (CONS L E)) T)
  ( T (CIRC (CDR L) (CONS L E)))))))))

(DE PPRINT (-X) (COND
  ((ATOM -X) (PRINT -X))
  ((CIRC -X) (CPRINT -X))
  (T (PRINT -X))))))))

(DE CPRINT (-X) (PRIN1 '/() (CPRIN1 -X NIL) '/ )


(DE CPRIN1 (L E) (COND
  ((NULL L) (PRIN1 '/)))
  ((MEMQ L E) (PRIN1 '*C* '/)))
  ((ATOM (CAR L)) (PRIN1 (CAR L)) (CPRIN1 (CDR L) (CONS L E)))
  (T (PRIN1 '/() (CPRIN1 (CAR L) (CONS L E))
                 (CPRIN1 (CDR L) (CONS L E)))))))))))))))

;;
;	TOP-LEVEL V ;
;;

(SETQ -TOP '(SIMREC (-TOPL NIL
  (PRINT '***/ / V/ / ***) (STATUS 11 '/$)
  (PRINT (EVAL (READ)))
  (STATUS 11 '/?)
  (-TOPL)
        ) (-TOPL)))))))))

;;
;	AINT'S  ;
;;

(PUT 'IF 'AIF 'AINT)
(DE AIF () (SAVEUP 'AIF1) (SETQ -EXP (CADR -EXP) -PC 'AEVAL))
(DE AIF1 ()
  (IF -VAL
    (SETQ -EXP (CADDR -EXP) -PC 'AEVAL)
    (SETQ -EXP (CDDDR -EXP) -PC 'APROGN))))))


(PUT 'PROGN  'APROGN0 'AINT)
(DE APROGN0 () (SETQ -EXP (CDR -EXP) -PC 'APROGN))))))
(DE APROGN ()
  (IF (CDR -EXP) (SAVEUP 'APROGN1))
  (SETQ -EXP (CAR -EXP) -PC 'AEVAL)))))))

(DE APROGN1 () (SETQ -EXP (CDR -EXP) -PC  'APROGN)))))))


(PUT 'DE 'ADE 'AINT)
(DE ADE ()
  (SET (CADR -EXP) ['BETA (CONS LAMBDA (CDDR -EXP)) NIL])
  (SETQ -VAL (CADR -EXP))
  (RESTORE))))


(PUT 'SIMREC 'ASIMREC 'AINT)
(DE ASIMREC (;; -Z) (NEXTL -EXP)
  (WHILE (CDR -EXP)
         (SETQ -Z (CONS [(CAAR -EXP)
                         ['BETA (CONS LAMBDA (CDAR -EXP)) NIL]]
                        -Z))
         (NEXTL -EXP))
  (MAPC -Z '(LAMBDA (-X) (RPLACA (CDDR (CADR -X)) -Z)))
  (SETQ -ENV (NCONC -Z -ENV) -EXP (CAR -EXP) -PC 'AEVAL)))))))))))

(PUT 'EVAL 'AEVALU 'AINT)
(DE AEVALU ()
  (SAVEUP 'AEVALU1) (SETQ -EXP (CADR -EXP) -PC 'AEVAL)))))))))

(DE AEVALU1 () (SETQ -EXP -VAL -PC 'AEVAL)))))))


(PUT 'LET 'ALET 'AINT)
(DE ALET ()
  (NEXTL -EXP)
  (SETQ -X (MAPCAR (CAR -EXP) 'CAR)
        -Y (MAPCAR (CAR -EXP) 'CADR)
        -EXP (CONS (CONS LAMBDA (CONS -X (CDR -EXP))) -Y)
        -PC 'AEVAL))))))))

(PUT 'SETQ 'ASETQ 'AINT)
(DE ASETQ () (SETQ -PC 'ASETQ1 -EXP (CDR -EXP)))))))
(DE ASETQ1 ()
  (IF (NULL -EXP) (RESTORE) (SAVEUP 'ASETQ2)
      (SETQ -EXP (CADR -EXP) -PC 'AEVAL)))))))
(DE ASETQ2 ()
  (SETQ -TEM (ASSQ (CAR -EXP) -ENV))
  (IF -TEM (RPLACA (CDR -TEM) -VAL) (SET (CAR -EXP) -VAL))
  (SETQ -PC 'ASETQ1 -EXP (CDDR -EXP)))))))

(PUT 'NEXTL 'ANEXTL 'AINT)
(DE ANEXTL ()
  (SETQ -EXP (CADR -EXP) -TEM (ASSQ -EXP -ENV))
  (COND
    (-TEM (SETQ -VAL (CAADR -TEM)) (RPLACA (CDR -TEM) (CDADR -TEM)))
    (T (SETQ -VAL (CAAR -EXP)) (SET -EXP (CDAR -EXP))))
  (RESTORE)))))))))


(PUT 'COND 'ACOND 'AINT)
(DE ACOND () (SETQ -PC 'ACOND1 -EXP (CDR -EXP)))))))
(DE ACOND1 ()
  (IF (NULL -EXP) (SETQ -VAL NIL -PC 'RESTORE)
      (SAVEUP 'ACOND2)
      (SETQ -EXP (CAAR -EXP) -PC 'AEVAL)))))))))
(DE ACOND2 ()
  (IF -VAL (IF  (NULL (CDAR -EXP)) (RESTORE)
                (SETQ -PC 'APROGN -EXP (CDAR -EXP)))
      (SETQ -EXP (CDR -EXP) -PC 'ACOND1))))))))))))


(PUT 'ESCAPE 'AESCAPE 'AINT)
(DE AESCAPE ()
  (SETQ -ENV (CONS [(CADR -EXP) ['DELTA -CLINK]] -ENV)
        -EXP (CDDR -EXP)
        -PC 'APROGN))))))))))

(PUT 'WHILE 'AWHILE 'AINT)
(DE AWHILE () (SETQ -PC 'AWHILE1 -EXP (CDR -EXP)))
(DE AWHILE1 ()
  (SAVEUP 'AWHILE2)
  (SETQ -EXP (CAR -EXP) -PC 'AEVAL))
(DE AWHILE2 ()
  (IF (NULL -VAL) (RESTORE)
      (SAVEUP 'AWHILE1)
      (SETQ -EXP (CDR -EXP) -PC 'APROGN))))))))))))



;;